home *** CD-ROM | disk | FTP | other *** search
/ Software Vault: The Diamond Collection / The Diamond Collection (Software Vault)(Digital Impact).ISO / cdr43 / ppl4p10.zip / TERM_IO.PAS < prev    next >
Pascal/Delphi Source File  |  1995-02-20  |  7KB  |  318 lines
  1. (* TERM_IO.PAS *)
  2.  
  3. {  $DEFINE DEBUG}
  4. {$I DEFINES.PAS}
  5.  
  6. (*********************************************)
  7. (*                                           *)
  8. (*  Used for I/O by TERM.PAS                 *)
  9. (*                                           *)
  10. (*  This program is donated to the Public    *)
  11. (*  Domain by MarshallSoft Computing, Inc.   *)
  12. (*  It is provided as an example of the use  *)
  13. (*  of the Personal Communications Library.  *)
  14. (*                                           *)
  15. (*********************************************)
  16.  
  17.  
  18. unit term_IO;
  19.  
  20. interface
  21.  
  22. Function  FetchName(var Filename : String) : Boolean;
  23. Procedure WriteColMsg(MsgString:String;StartCol,EndCol:Integer);
  24. Procedure SetMsgCol(Col:Integer);
  25. Procedure WriteMsg(MsgString:String);
  26. Procedure WriteBoolMsg(MsgString:String; Parm:Boolean);
  27. Procedure WriteIntMsg(MsgString:String; Parm:Integer);
  28. Procedure WriteLongMsg(MsgString:String; Parm:LongInt);
  29. Procedure ReadMsg(VAR MsgString:String; StartCol, MaxLength:Byte);
  30. Procedure PutChar(Port:Integer; c:Byte);
  31. Function  GetChar(Port:Integer; Timeout:Integer):Integer;
  32. Procedure SayError(Code:Integer;Message:String);
  33. Procedure TxCAN(Port:Integer);
  34. Function  MatchBaud(BaudString : String) : Integer;
  35. Procedure MsgEcho(Flag : Boolean);
  36. Procedure WriteCPS(StartTics:LongInt;FileBytes:LongInt;Filename:String;Skipped:Boolean);
  37.  
  38. implementation
  39.  
  40. uses PCL4P,HEX_IO,CRT;
  41.  
  42. const
  43.   CR  : Byte = $0d;
  44.   ESC : Byte = $1B;
  45.   BS  : Byte = $08;
  46.   BLK : Byte = $20;
  47.   CAN : Byte = $18;
  48.  
  49. var
  50.   EchoFlag    : Boolean;
  51.   MsgStartCol : Integer;
  52.  
  53. Procedure MsgEcho(Flag : Boolean);
  54. Begin
  55.   EchoFlag := Flag;
  56. End;
  57.  
  58. Procedure SetMsgCol(Col:Integer);
  59. begin
  60.   MsgStartCol := Col
  61. end;
  62.  
  63. Procedure WriteColMsg(MsgString:String;StartCol,EndCol:Integer);
  64. var
  65.   i:Integer;
  66.   Row:Byte;
  67.   Col:Byte;
  68. begin
  69.   If EchoFlag Then WriteLn(StartCol,'<',MsgString,'>');
  70.   Col := WhereX;
  71.   Row := WhereY;
  72.   (* goto display window *)
  73.   Window(1,25,80,25);
  74.   HighVideo;
  75.   GotoXY(StartCol,1);
  76.   Write(MsgString);
  77.   for i := WhereX+1 to EndCol do Write(' ');
  78.   (* back to main window *)
  79.   Window(1,1,80,24);
  80.   LowVideo;
  81.   GotoXY(Col,Row);
  82. end;
  83.  
  84. Procedure WriteMsg(MsgString:String);
  85. begin
  86.   WriteColMsg(MsgString,MsgStartCol,79)
  87. end;
  88.  
  89. Procedure WriteBoolMsg(MsgString:String; Parm:Boolean);
  90. Var
  91.   Temp   : String;
  92. begin
  93.   if Parm then Temp := 'True'
  94.   else Temp := 'False';
  95.   WriteMsg(MsgString+Temp);
  96. end;
  97.  
  98. Procedure WriteIntMsg(MsgString:String; Parm:Integer);
  99. var
  100.   Temp   : String;
  101. begin
  102.   str(Parm,Temp);
  103.   WriteMsg(MsgString+Temp);
  104. end;
  105.  
  106. Procedure WriteLongMsg(MsgString:String; Parm:LongInt);
  107. var
  108.   Temp   : String;
  109. begin
  110.   str(Parm,Temp);
  111.   WriteMsg(MsgString+Temp);
  112. end;
  113.  
  114. Procedure ReadMsg(VAR MsgString:String; StartCol, MaxLength:Byte);
  115. Label 999;
  116. var
  117.   Row:Byte;
  118.   Col:Byte;
  119.   i  :Byte;
  120.   c  :Char;
  121. begin
  122.   Row := WhereY;
  123.   Col := WhereX;
  124.   (* goto  display window *)
  125.   Window(1,25,80,25);
  126.   HighVideo;
  127.   (* input text from user *)
  128.   i := 0;
  129.   while true do
  130.      begin
  131.        GotoXY(StartCol+i,1);
  132.        c := ReadKey;
  133.        case ord(c) of
  134.          $0D : goto 999;
  135.          $1B : (* Escape *)
  136.            begin
  137.              (* return empty string *)
  138.              i := 0;
  139.              goto 999;
  140.            end;
  141.          $08 : (* backspace *)
  142.            begin
  143.              (* back up if can *)
  144.              if i > 0 then
  145.                begin
  146.                  (* adjust buffer *)
  147.                  i := i - 1;
  148.                  (* write blank at cursor *)
  149.                  GotoXY(StartCol+i,1);
  150.                  write(' ');
  151.                  GotoXY(StartCol+i,1)
  152.                end
  153.            end
  154.        else (* not one of above special chars *)
  155.          begin
  156.            (* save character *)
  157.            i := i + 1;
  158.            MsgString[i] := c;
  159.            (* display on bottom line *)
  160.            Write(c);
  161.            (* done ? *)
  162.            if i = MaxLength then goto 999;
  163.          end
  164.        end (* case *)
  165.      end; (* end while *)
  166. 999:(* set length *)
  167.   MsgString[0] := chr(i);
  168.   (* back to main window *)
  169.   Window(1,1,80,24);
  170.   LowVideo;
  171.   GotoXY(Col,Row);
  172. end;
  173.  
  174. (*** Send character over serial line ***)
  175.  
  176. Procedure PutChar(Port:Integer; C:Byte);
  177. var
  178.   Code:Integer;
  179. begin
  180.   Code := SioPutc(Port,chr(C));
  181.   if Code < 0 then
  182.      begin
  183.        writeln('COM',1+Port,' error');
  184.        Code := SioError(Code);
  185.        Code := SioDone(Port);
  186.        Halt;
  187.      end;
  188. {$IFDEF DEBUG}
  189.   if (C < $20) or (C > $7E) then
  190.     begin
  191.       write('[$');
  192.       WriteHexByte(C);
  193.       write(']');
  194.     end
  195.   else write( chr(C) );
  196. {$ENDIF}
  197. end;
  198.  
  199. (*** Receive character from serial line ***)
  200.  
  201. Function GetChar(Port:Integer; Timeout:Integer):Integer;
  202. var
  203.   Code:Integer;
  204. begin
  205.   Code := SioGetc(Port,Timeout);
  206.   if Code < -1 then
  207.     begin
  208.       writeln('COM',1+Port,' error');
  209.       Code := SioError(Code);
  210.       Halt;
  211.     end;
  212. {$IFDEF DEBUG}
  213.   if (Code < $20) or (Code > $7E) then
  214.     begin
  215.       write('($');
  216.       WriteHexByte(Code);
  217.       write(')');
  218.     end
  219.   else write( chr(Code) );
  220. {$ENDIF}
  221.   GetChar := Code;
  222. end;
  223.  
  224. (*** Say error code ***)
  225.  
  226. procedure SayError(Code:Integer;Message:String);
  227. var
  228.    RetCode:Integer;
  229. begin
  230.    writeln(Message);
  231.    if Code < 0 then RetCode := SioError( Code )
  232.    else if (Code and (FramingError or ParityError or OverrunError)) <> 0 then
  233.       begin (* Port Error *)
  234.          if (Code and FramingError) <> 0 then writeln('Framing Error');
  235.          if (Code and ParityError)  <> 0 then writeln('Parity Error');
  236.          if (Code and OverrunError) <> 0 then writeln('Overrun Error')
  237.       end
  238. end;
  239.  
  240. (*** Transmits CAN's ***)
  241.  
  242. Procedure TxCAN(Port:Integer);
  243. const
  244.   CAN = $18;
  245. var
  246.   I : Integer;
  247.   Code : Integer;
  248. begin
  249.   for I:=1 to 6 do Code := SioPutc(Port,chr(CAN));
  250. end;
  251.  
  252. (*** get baud code from baud rate string ***)
  253.  
  254. function MatchBaud(BaudString : String) : Integer;
  255. const
  256.    BaudRateArray : array[1..10] of LongInt =
  257.        (300,600,1200,2400,4800,9600,19200,38400,57600,115200);
  258. var
  259.    i : Integer;
  260.    BaudRate: LongInt;
  261.    RetCode : Integer;
  262. begin
  263.   Val(BaudString,BaudRate,RetCode);
  264.   if RetCode <> 0 then
  265.   begin
  266.     MatchBaud := -1;
  267.     exit;
  268.   end;
  269.   for i := 1 to 10 do if BaudRateArray[i] = BaudRate then
  270.   begin
  271.     MatchBaud := i - 1;
  272.     exit;
  273.   end;
  274.   (* no match *)
  275.   MatchBaud := -1;
  276. end;
  277.  
  278. (* ask user for filename if 'Filename' is empty *)
  279.  
  280. function FetchName(var Filename : String) : Boolean;
  281. var Text : String;
  282. begin
  283.   FetchName := True;
  284.   if Length(Filename) = 0 then
  285.     begin
  286.       WriteMsg('Enter filename: ');
  287.       ReadMsg(Text,MsgStartCol+15,20);
  288.       Filename := Text;
  289.       if Length(FileName) = 0 then FetchName := False;
  290.     end;
  291. end;
  292.  
  293. (* write CPS *)
  294.  
  295. Procedure WriteCPS(StartTics:LongInt;FileBytes:LongInt;Filename:String;Skipped:Boolean);
  296. var
  297.   CPS  : Integer;
  298.   Tics : LongInt;
  299.   Secs : LongInt;
  300.   Temp : String;
  301. begin
  302.   if Length(Filename) = 0 then exit;
  303.   if not Skipped then
  304.     begin
  305.       Secs := (SioTimer - StartTics) DIV 18;
  306.       if Secs>0 then CPS := Integer(FileBytes DIV Secs)
  307.       else Skipped := True;
  308.     end;
  309.   if Skipped then writeln(Filename+' skipped (',FileBytes,' bytes)')
  310.   else writeln(Filename+' transferred (',FileBytes,' bytes)')
  311. end;
  312.  
  313. begin
  314.   EchoFlag := False;
  315.   MsgStartCol := 1;
  316. end.
  317.  
  318.